package Class::Guile;
use warnings;
use strict;

use Guile;
use Inline 'Guile';
use Scalar::Util qw(blessed);

sub import {
    my ( $class, $flag ) = @_;
    my $caller = scalar( caller );

    if ( $flag eq '-base' ) {
        no strict 'refs';
        push @{ $caller . '::ISA' }, $class;
        *{ $caller . '::guile_method' } = \&__declare_guile_method;
    }

    1;
}

sub new { 
    bless { 
        runner => Guile::lookup( 'perl-horizon-space' ) 
    } => shift;
}
sub __runner { $_[0]->{ runner } }

sub __declare_guile_method {
    my ( $name, $def ) = @_;
    my $class = scalar( caller );
    my $code  = Guile::eval_str( $def );

    {   no strict 'refs';
        *{ $class . '::' . $name } = sub {
            my ( $self, @args ) = @_;
            return $code->( @args );
        };
    }
}

our %scoped_values;

sub call_wrapped {
    my ( $self, $code, $values ) = @_;
    $values ||= {};

    print "PRECAP CODE: $code\n";
    $code = $self->__encapsulate_named( $code, $values );
    print "POSTCAP CODE: $code\n";
    local %scoped_values = ( named => $values );
    my $r = $self->__runner;
    my $set_new_val;
    my $new_val = $code;
    my $anon_idx = 0;

  CALLCYCLE:

    while (1) {

        $r = $r->( $new_val );
        undef $new_val;
        # TODO gehoert in die schleife
#        if ( $set_new_val ) {
#            $set_new_val = 0;
#        }
        
        my $mark = $r->[0];
        
        return wantarray ? $r->[ 1..$#{$r} ] : $r->[1]
            if $mark eq 'perl-leave-horizon-space';
        
        if ( $mark eq 'perl-horizon-jump' ) {
            my $cont = $r->[1];
#            print "CONT $cont\n";
#            print "TWO " . $r->[2] . "\n";
            my $type = $r->[2][0];
            my $hook = $r->[2][1];
#            print "Hook[$type]: $hook\n";
            die "Unknown $type hook: $hook\n"
                unless exists $scoped_values{ $type }{ $hook };
            
            
            my $val = $scoped_values{ $type }{ $hook };
            my $args = $r->[2][2] || [];
#            my $raw_value = 1;
            if ( ref $val eq 'CODE' ) {
                print "R IS [" . join( ', ', @$args ) . "]\n";
                
                $new_val = $val->( @$args );
#                $raw_value = 0;
#                $set_new_val = 1 if ref $new_val;
            }
#            elsif ( not ref $val ) {
#                $raw_value = 1;
#                $new_val = $val;
#            }
            else {
                die "Don't know what to do with $val\n";
            }
            print "VAL $val\n";
            print "NEWVAL $new_val\n";
            print "RNEWVAL " . ref( $new_val ) . "\n";

            my $raw_value = 1 if blessed $new_val and $new_val->isa( 'Guile::SCM' );
            if ( ref $new_val and not $raw_value ) {
                my $idx = $anon_idx++;
                print "Stored new anon ($new_val) under $idx\n";
                $scoped_values{ anon }{ $idx } = $new_val;
#                    $self->__encapsulate_anon( $idx, $new_val );
                $new_val = $self->__encapsulate_anon( $idx, $new_val );
            }

            
            $r = $cont;
            
#            $r = $cont->( $new_val );
            
            next CALLCYCLE;
        }

        die "Unknown mark: $mark\n";
    }    
}

sub __encapsulate_anon {
    my ( $self, $key, $value ) = @_;
    return Guile::eval_str('#f') unless defined $value;
    return $value unless ref $value;
    my $prepped = $self->__prepare_value( anon => $key => $value );
    return Guile::eval_str( $prepped );
}

sub __encapsulate_named {
    my ( $self, $code, $values ) = @_;
    $code = '' unless defined $code;

    my @scopings = 
        map  { "($_ " . $self->__prepare_value( named => $_ => $values->{ $_ } ) . ')' }
        keys %$values;

    return '(let (' . join( ' ' => @scopings ) . ') ' . $code . ')';
}

sub __prepare_value {
    my ( $self, $key, $name, $value ) = @_;
#    print "Preparing $name -> $value\n";
    
    if ( ref $value ) {
#        print "Preparing $key referenced value\n";
        return "(lambda args (perl-horizon-jump '$key '$name args))";
    }
    elsif ( not defined $value ) {
#        print "Preparing undefined value\n";
        return '#f';
    }
    else {
#        print "Preparing scalar value\n";
        my $transformer = Guile::eval_str(q(
            (lambda (p) (with-output-to-string (lambda () (write p))))
        ));
        return $transformer->( $value );
    }
}

=for Hastur

sub call_wrapped {
    my ( $self, $code, $values ) = @_;
    $values ||= {};

    local %scoped_values = ( %$values, %scoped_values );
    return $self->__evaluate_guile_code( $code, [ keys %scoped_values ] );
}

sub __evaluate_guile_code {
    my ( $self, $code, $scoped ) = @_;
    $code = $self->__encapsulate_in_scope( $code, $scoped );
    print "CODE:\n$code\n";
    
    my $r = $self->__runner->( $code );


    while (1) { # TODO second loop for re-localization, has to happen in here.
        my $mark = $r->[0];
        
        return wantarray ? $r->[1 .. $#{$r}] : $r->[1]
            if $mark eq 'perl-leave-horizon-space';
        
        if ( $mark eq 'perl-horizon-jump' ) {
            my $cont = $r->[1];
#            print "CONT $cont\n";
            $r = $cont->( $self->__handle_hook( $r ) );
            
            next;
        }

        die "Unknown mark: $mark\n";
    }
}

sub __handle_hook {
    my ( $self, $r ) = @_;
    print "Hook.\n";
    my $x = $r->[2][0];
    print "X is $x\n";
    return $scoped_values{ $r->[2][0] };
    1;
}

=cut

1;

__DATA__
__Guile__

(define call/cc call-with-current-continuation)
(define perl-horizon-jump (lambda p
  (call/cc (lambda (k) ( (throw 'perl-horizon-jump k p ))))))
(define perl-horizon-space
  (lambda (expr)
    (catch 'perl-leave-horizon-space
      (lambda ()
        (catch 'perl-horizon-jump
          (lambda () (throw 'perl-leave-horizon-space
                            (eval-string expr)))
          (lambda (key k p) (list key k p))))
      (lambda (key p)
        (list key p)))))

